home *** CD-ROM | disk | FTP | other *** search
/ Chip 2004 April / CMCD0404.ISO / Software / Shareware / Programare / sharp / wwwSharp_setup.exe / {app} / Examples / RssPublisher / Source / RSSpub.vbs < prev    next >
Text File  |  2004-02-04  |  10KB  |  374 lines
  1. ' ============================================
  2. ' this file contains functions that you can use to fill a string with 
  3. ' ASPRSS-compliant XML. This string can be stored in the file RSS.xml 
  4. ' or sent directly to the client.
  5. '
  6. ' home:    http://ASPRSS.com/
  7. ' discuss:  http://www.asplists.com/asplists/asprss.asp
  8. ' validate: http://ASPRSS.com/RSSform.asp
  9. ' ============================================
  10. Dim sRSSXML            ' contains resulting XML
  11. Dim sItems                ' contains contents of <items> element
  12.  
  13. ' ============================================
  14. ' Returns indentation string from indent level
  15. ' ============================================
  16. Function GetIndentString(iIndent)
  17.     GetIndentString = String(2*iIndent, " ")
  18. End Function
  19.  
  20. ' ============================================
  21. ' adds header to sRSSXML
  22. '
  23. ' The following parameters are mandatory:
  24. '  sSiteTitle, sSiteDescr, sSiteURL
  25. '
  26. ' The following parameters are optional:
  27. '  sSiteDetails, sImageURL, sAuthorNames, sAuthorEmails
  28. '  sFurtherReading
  29. '
  30. ' Note: sAuthorNames, sAuthorEmails and sFurtherReading can contain 
  31. '  multiple entries, separated by |. 
  32. '
  33. ' Both sAuthorNames and sAuthorEmails *must* have the same 
  34. '  number of  elements, but elements can be empty if required.
  35. ' ============================================
  36. Function RSSheader ( sSiteTitle, sSiteDescr, sSiteURL, sSiteDetails, sImageURL, sFurtherReading, sAuthorNames, sAuthorEmails ) 
  37.  
  38.     If Len ( sSiteTitle ) = 0 Or Len ( sSiteDescr ) = 0 Or Len ( sSiteURL ) = 0 Then
  39.         'Response.Write ( "<p>Must pass sSiteTitle,sSiteDescr,sSiteURL into RSSheader<p>" )
  40.         RSSheader = False
  41.         Exit Function
  42.     End If
  43.  
  44.     ' add header to XML string
  45.     sRSSXML = "<?xml version=""1.0""?>" & chr(10)
  46.  
  47.     sRSSXML = sRSSXML & "<rdf:RDF" & chr(10)
  48.     
  49.     ' specify namespaces
  50.     sRSSXML = sRSSXML & "  xmlns:rdf=""http://www.w3.org/1999/02/22-rdf-syntax-ns#""" & chr(10)
  51.     sRSSXML = sRSSXML & "  xmlns:dc=""http://purl.org/dc/elements/1.1/""" & chr(10)
  52.     sRSSXML = sRSSXML & "  xmlns:fr=""http://ASPRSS.com/fr.html""" & chr(10)
  53.     sRSSXML = sRSSXML & "  xmlns:pa=""http://ASPRSS.com/pa.html""" & chr(10)
  54.     sRSSXML = sRSSXML & "  xmlns=""http://purl.org/rss/1.0/"">" & chr(10)
  55.  
  56.     ' specify channel
  57.     sRSSXML = sRSSXML & "<channel rdf:about=""" + sSiteURL + """>" & chr(10)
  58.  
  59.         If Not RSStag ( sRSSXML, "title", sSiteTitle, 1 ) Then
  60.             RSSheader = False
  61.             Exit Function
  62.         End If
  63.  
  64.         If Not RSStag ( sRSSXML, "link", sSiteURL, 1 ) Then
  65.             RSSheader = False
  66.             Exit Function
  67.         End If
  68.  
  69.         If Not RSStag ( sRSSXML, "description", sSiteDescr, 1 ) Then
  70.             RSSheader = False
  71.             Exit Function
  72.         End If
  73.  
  74.         If Len ( sSiteDetails ) > 0 Then
  75.             If Not RSStag ( sRSSXML, "dc:publisher", sSiteDetails, 1 ) Then
  76.                 RSSheader = False
  77.                 Exit Function
  78.             End If
  79.         End If
  80.  
  81.         If Len ( sFurtherReading ) > 0 Then
  82.             If  Not RSStag ( sRSSXML, "fr:url", sFurtherReading, 1 ) Then
  83.                 RSSheader = False
  84.                 Exit Function
  85.             End If
  86.         End If
  87.  
  88.         If Len ( sAuthorNames ) > 0 Then
  89.             If Not RSSauthor ( sRSSXML, sAuthorNames, sAuthorEmails, 1 ) Then
  90.                 RSSheader = False
  91.                 Exit Function
  92.             End If
  93.         End If
  94.  
  95.         If Len ( sImageURL ) > 0 Then
  96.             sRSSXML = sRSSXML & GetIndentString(1) & "<image rdf:resource=""" + sImageURL + """ />" & chr(10)
  97.         End If
  98.         
  99.         ' add empty <items>, filled in later by RSSfooter()
  100.         If Not RSStag ( sRSSXML, "items", "", 1 ) Then
  101.             RSSheader = False
  102.             Exit Function
  103.         End If
  104.  
  105.         ' initialize <items> store
  106.         sItems = ""
  107.  
  108.     ' close channel
  109.     sRSSXML = sRSSXML & "</channel>" & chr(10)
  110.  
  111.     ' add optional image
  112.     If Len ( sImageURL ) > 0 Then
  113.  
  114.         sRSSXML = sRSSXML & GetIndentString(1) & "<image rdf:about=""" + sImageURL + """>" & chr(10)
  115.  
  116.             If Not RSStag ( sRSSXML, "title", sSiteTitle, 2 ) Then
  117.                 RSSheader = False
  118.                 Exit Function
  119.             End If
  120.  
  121.             If Not RSStag ( sRSSXML, "url", sImageURL, 2 ) Then
  122.                 RSSheader = False
  123.                 Exit Function
  124.             End If
  125.  
  126.             If Not RSStag ( sRSSXML, "link", sSiteURL, 2 ) Then
  127.                 RSSheader = False
  128.                 Exit Function
  129.             End If
  130.  
  131.         sRSSXML = sRSSXML & GetIndentString(1) & "</image>" & chr(10)
  132.  
  133.     End If
  134.  
  135.     RSSheader = True
  136.  
  137. End Function
  138.  
  139. ' ============================================
  140. ' adds item to sRSSXML
  141. '
  142. ' The following parameters are mandatory:
  143. '  sTitle, sDescr, sURL
  144. '
  145. ' The following parameters are optional:
  146. '  sDate, sCategory, sKeywords, sAuthorNames, sAuthorEmails
  147. '
  148. ' Note: sAuthorNames and sAuthorEmails can contain multiple entries, 
  149. '  separated by |. Both *must* have the same number of  elements,
  150. '  but elements can be empty if required.
  151. ' 
  152. ' sKeywords can contain multiple keywords, but all will be grouped
  153. '  in a single element. Keywords should be seperated by commas.
  154. ' ============================================
  155. Function RSSitem ( sTitle, sDescr, sURL, sDate, sCategory, sKeywords, sAuthorNames, sAuthorEmails ) 
  156.  
  157.     Dim dDate
  158.     Dim sMonth 
  159.     Dim sDay
  160.     Dim sValidDate
  161.     'VVV - create each item as string and later add it to sRSSXML, better memory usage
  162.     Dim sItem 
  163.  
  164.     If Len ( sTitle ) = 0 Or Len ( sDescr ) = 0 Or Len ( sURL ) = 0 Then
  165.         'Response.Write ( "<p>Must pass sTitle,sDescr,sURL into RSSitem<p>" )
  166.         RSSitem = False
  167.         Exit Function
  168.     End If
  169.  
  170.     ' start new <resource>
  171.     sItem = sItem & GetIndentString(1) & "<item rdf:about=""" & sURL & """>" & chr(10)
  172.  
  173.         If Not RSStag ( sItem, "title", sTitle, 2 ) Then
  174.             RSSitem = False
  175.             Exit Function
  176.         End If
  177.  
  178.         If Not RSStag ( sItem, "description", sDescr, 2 ) Then
  179.             RSSitem = False
  180.             Exit Function
  181.         End If
  182.  
  183.         If Not RSStag ( sItem, "link", sURL, 2 ) Then
  184.             RSSitem = False
  185.             Exit Function
  186.         End If
  187.  
  188.         If Len ( sDate ) > 0 Then
  189.             ' make it a valid date according to 
  190.             ' http://www.w3.org/TR/NOTE-datetime
  191.  
  192.             ' get a date object
  193.             dDate = DateValue ( sDate )
  194.  
  195.             ' make sure month is 2 digits
  196.             sMonth = Right ( "0" & Month ( dDate ), 2)
  197.  
  198.             ' make sure day is 2 digits
  199.             sDay = Right ( "0" & Day ( dDate ), 2)
  200.  
  201.             ' make valid date
  202.             sValidDate = Year ( dDate ) & "-" & sMonth & "-" & sDay
  203.  
  204.             If Not RSStag ( sItem, "dc:date", sValidDate, 2 ) Then
  205.                 RSSitem = False
  206.                 Exit Function
  207.             End If
  208.         End If
  209.  
  210.         If Len ( sCategory ) > 0 Then
  211.             If Not RSStag ( sItem, "pa:category", sCategory, 2 ) Then
  212.                 RSSitem = False
  213.                 Exit Function
  214.             End If
  215.         End If
  216.  
  217.         If Len ( sKeywords ) > 0 Then
  218.             If Not RSStag ( sItem, "pa:keywords", sKeywords, 2 ) Then
  219.                 RSSitem = False
  220.                 Exit Function
  221.             End If
  222.         End If
  223.  
  224.         If Len ( sAuthorNames ) > 0 Then
  225.             If Not RSSauthor ( sItem, sAuthorNames, sAuthorEmails, 2 ) Then
  226.                 RSSitem = False
  227.                 Exit Function
  228.             End If
  229.         End If
  230.  
  231.     ' add to <items> store
  232.     sItems = sItems & GetIndentString(3) & "<rdf:li rdf:resource=""" & sURL & """/>" & chr(10)
  233.  
  234.     sItem = sItem & GetIndentString(1) & "</item>" & chr(10)
  235.  
  236.     sRSSXML = sRSSXML & sItem
  237.     RSSitem = True
  238.  
  239. End Function
  240.  
  241. ' ============================================
  242. ' adds footer to sRSSXML
  243. ' ============================================
  244. Function RSSfooter ( ) 
  245.  
  246.     Dim nItemsPos
  247.  
  248.     sRSSXML = sRSSXML & "</rdf:RDF>" & chr(10)
  249.  
  250.     ' fill in <items> element
  251.     nItemsPos = InStr ( sRSSXML, "</items>" )
  252.  
  253.     If nItemsPos = 0 Then
  254.         'Response.Write ( "<p>Missing <items> element<p>" )
  255.         RSSfooter = False
  256.         Exit Function
  257.     End If
  258.  
  259.     sRSSXML = Left ( sRSSXML, nItemsPos-1 ) & chr(10) & GetIndentString(2) & "<rdf:Seq>" & chr(10) & _
  260.         sItems & GetIndentString(2) & "</rdf:Seq>" & chr(10) & GetIndentString(1) & Mid ( sRSSXML, nItemsPos )
  261.  
  262.     RSSfooter = True
  263.  
  264. End Function
  265.  
  266. ' ============================================
  267. ' stores sRSSXML to file
  268. '
  269. ' The following parameters are mandatory:
  270. '  sFilename
  271. '
  272. ' note: requires write permission to file sFilename
  273. ' ============================================
  274. Function RSSpersist ( sFilename ) 
  275.  
  276.     Dim oFSO
  277.     Dim fFile
  278.  
  279.     ' create an instance of the FileSystemObject
  280.     'Set oFSO = Server.CreateObject ( "Scripting.FileSystemObject" )
  281.     Set oFSO = CreateObject ( "Scripting.FileSystemObject" )
  282.  
  283.     ' create file
  284.     'Set fFile = oFSO.CreateTextFile ( Server.MapPath ( sFilename ) )
  285.     Set fFile = oFSO.CreateTextFile ( sFilename )
  286.  
  287.     fFile.WriteLine ( sRSSXML )
  288.  
  289.     fFile.Close 
  290.  
  291.     Set fFile = Nothing
  292.     Set oFSO = Nothing
  293.  
  294.     RSSpersist = True
  295.  
  296. End Function
  297.  
  298. ' ============================================
  299. ' INTERNAL USE ONLY - DO NOT CALL DIRECTLY
  300. '
  301. ' store tag + value
  302. '
  303. ' The following parameters are mandatory:
  304. '  sTag, sValue
  305. ' ============================================
  306. Function RSStag ( ByRef sXml, sTag, sValue, iIndent )
  307.  
  308.     Dim Reg
  309.     Dim sStripped
  310.  
  311.     ' regular expression to remove HTML
  312.     Set Reg = New Regexp
  313.     Reg.Pattern = "<[^>]*>"
  314.     Reg.Global = True
  315.  
  316.     sStripped = Reg.Replace ( sValue, "" )
  317.  
  318.     sXml = sXml & GetIndentString(iIndent) & "<" & sTag & ">" & sStripped & "</" & sTag & ">" & chr(10)
  319.  
  320.     RSStag = True
  321.  
  322. End Function
  323.  
  324. ' ============================================
  325. ' INTERNAL USE ONLY - DO NOT CALL DIRECTLY
  326. '
  327. ' store authors in <dc:creator>'s
  328. '
  329. ' The following parameters are mandatory:
  330. '  sAuthorNames, sAuthorEmails
  331. '
  332. ' note: sName and sEmail *must* have the same number of  elements
  333. ' ============================================
  334. Function RSSauthor ( ByRef sXml, sAuthorNames, sAuthorEmails, iIndent )
  335.  
  336.     Dim sNames
  337.     Dim sEmails
  338.     Dim sName 
  339.     Dim sEmail
  340.     Dim I
  341.     
  342.     sNames = Split ( sAuthorNames, "|" )
  343.     sEmails = Split ( sAuthorEmails, "|" )
  344.  
  345.     If UBound ( sNames ) <> UBound ( sEmails ) Then
  346.         'Response.Write ( "<p>Must pass equal number of elements to RSSauthor<p>" )
  347.         RSSauthor = False
  348.         Exit Function
  349.     End If
  350.  
  351.     For I = 0 To UBound ( sNames )
  352.         sXml = sXml & GetIndentString(iIndent) & "<dc:creator>"
  353.  
  354.             sName = sNames ( I )
  355.             sEmail = sEmails ( I )
  356.  
  357.             ' add spaces and braces if both specified
  358.             If Len ( sName ) > 0 Then
  359.                 If Len ( sEmail ) > 0 Then
  360.                     sXml = sXml & sName & " (mailto:" & sEmail & ")"
  361.                 Else
  362.                     sXml = sXml & sName
  363.                 End If
  364.             Else
  365.                 sXml = sXml & "mailto:" & sEmail
  366.             End If
  367.                 
  368.         sXml = sXml & "</dc:creator>" & chr(10)
  369.     Next
  370.  
  371.     RSSauthor = True
  372.  
  373. End Function
  374.